home *** CD-ROM | disk | FTP | other *** search
/ ShareWare OnLine 2 / ShareWare OnLine Volume 2 (CMS Software)(1993).iso / cad / mar93cad.zip / PARABOLA.LSP next >
Lisp/Scheme  |  1993-02-13  |  7KB  |  229 lines
  1. ;==========================================================
  2. ; PARABOLA.LSP Copyright 1992 by Looking Glass Microproducts
  3. ;==========================================================
  4. (if (null PARABOLA_SEGS)
  5.    (setq PARABOLA_SEGS 12)  ; default number of parabola segments
  6. )
  7. (defun C:PARABOLA (/ ERROR PUSHVARS POPVARS NOTRANS PARABOLA SQR
  8.                    MIDPOINT 2D RTOD SYSVARS)
  9.    ;==========================================================
  10.    ; Error Handler
  11.    (defun ERROR (S)
  12.       (if (not
  13.              (member
  14.                 S
  15.                 '("Function cancelled" "console break")
  16.              )
  17.           )
  18.          (princ S)
  19.       )
  20.       (command "_undo" "end")
  21.       (command "_undo" "1")
  22.       (POPVARS)
  23.    )
  24.    ;==========================================================
  25.    ; Set and Save System Variables
  26.    (defun PUSHVARS (VLIST)
  27.       (foreach PAIR VLIST
  28.          (setq
  29.             SYSVARS (cons
  30.                        (cons
  31.                           (strcase (car PAIR))
  32.                           (getvar
  33.                              (car PAIR)
  34.                           )
  35.                        )
  36.                        SYSVARS
  37.                     )
  38.          )
  39.          (if (cdr PAIR) (setvar (car PAIR) (cdr PAIR)))
  40.       )
  41.       t
  42.    )
  43.    ;==========================================================
  44.    ; Restore System Variables
  45.    (defun POPVARS ()
  46.       (foreach PAIR SYSVARS (setvar (car PAIR) (cdr PAIR)))
  47.       (setq
  48.          *error* OLD-ERROR
  49.       )
  50.       (setq SYSVARS nil)
  51.       (princ)
  52.    )
  53.    ;==========================================================
  54.    ; Restore a single system variable from stack
  55.    (defun RESTORE (VARNAME / OLD-VALUE)
  56.       (if (setq
  57.              OLD-VALUE (cdr (assoc (strcase VARNAME) SYSVARS))
  58.           )
  59.          (setvar VARNAME OLD-VALUE)
  60.       )
  61.    )
  62.    ;==========================================================
  63.    ; Disallow transparent invocation of routine.
  64.    (defun NOTRANS ()
  65.       (cond
  66.          ((zerop (logand (getvar "cmdactive") (+ 1 2 4 8))))
  67.          ((alert
  68.              "This command may not be invoked transparently."
  69.           )
  70.          )
  71.       )
  72.    )
  73.    ;===========================================================
  74.    ; Square function
  75.    (defun SQR (X) (* X X))
  76.    ;===========================================================
  77.    ; Midpoint between p1 and p2
  78.    (defun MIDPOINT (P1 P2)
  79.       (mapcar '(lambda (X1 X2) (* 0.5 (+ X1 X2))) P1 P2)
  80.    )
  81.    ;===========================================================
  82.    ; Set z to zero
  83.    (defun 2D (P) (mapcar '* P '(1 1)))
  84.    ;==========================================================
  85.    ; Radians to degrees
  86.    (defun RTOD (X) (/ (* 180.0 X) pi))
  87.    ;===========================================================
  88.    ; extended getint
  89.    (defun XGETINT (PRMPT DEFAULT)
  90.       (cond
  91.          ((getint (strcat PRMPT " <" (itoa DEFAULT) ">: ")))
  92.          (DEFAULT
  93.          )
  94.       )
  95.    )
  96.    ;============================================================
  97.    ; List of points on parabola with vertex at p0 through p1
  98.    (defun PARAB (P0 P1 / X0 X1 Y0 Y1 A DX POINTS X Y)
  99.       (setq X0 (car P0) Y0 (cadr P0) X1 (car P1) Y1 (cadr P1))
  100.       (if (/= X0 X1)
  101.          (progn
  102.             (setq
  103.                A      (/ (- Y1 Y0) (SQR (- X1 X0)))
  104.                DX     (/ (* 2 (- X1 X0)) PARABOLA_SEGS)
  105.                POINTS (list (list X1 Y1))
  106.                X      X1
  107.             )
  108.             (repeat
  109.                PARABOLA_SEGS
  110.                (setq
  111.                   X      (- X DX)
  112.                   Y      (+ (* A (SQR (- X X0))) Y0)
  113.                   POINTS (cons (list X Y) POINTS)
  114.                )
  115.             )
  116.             POINTS
  117.          )
  118.       )
  119.    )
  120.    ;==========================================================
  121.    ; Parabola main routine
  122.    (defun PARABOLA (/ P0 P1 P1W P2 P3 P3W POINTS ANG)
  123.       (graphscr)
  124.       (initget 1 "Segments")
  125.       (setq
  126.          P0 (getpoint "\nSegments/<start point>: ")
  127.       )
  128.       (if (= "Segments" P0)
  129.          (progn
  130.             (initget 6) ; disallow zero, negative
  131.             (setq
  132.                PARABOLA_SEGS (*
  133.                                 (/
  134.                                    (1+
  135.                                       (XGETINT
  136.                                          "\nNumber of segments"
  137.                                          PARABOLA_SEGS
  138.                                       )
  139.                                    )
  140.                                    2
  141.                                 )
  142.                                 2
  143.                              )
  144.             )
  145.             (initget 1) ; disallow nil input
  146.             (setq P0 (getpoint "\nStart point: "))
  147.          )
  148.       )
  149.       (setq P0 (2D P0))
  150.       ;
  151.       (initget 1)
  152.       (setq P1 (2D (getpoint P0 "\nEnd point: ")))
  153.       (while (equal P0 P1)
  154.          (prompt
  155.             "\nPoints must be distinct."
  156.          )
  157.          (initget 1)
  158.          (setq
  159.             P1 (2D (getpoint P0 "\nTry again: "))
  160.          )
  161.       )
  162.       ;
  163.       (setq P2 (MIDPOINT P0 P1) ANG (angle P0 P1))
  164.       (setvar
  165.          "blipmode" 0
  166.       )
  167.       (command "_snap" "rotate" P2 (RTOD ANG))
  168.       (RESTORE
  169.          "snapmode"
  170.       )
  171.       (RESTORE "blipmode")
  172.       (setvar "orthomode" 1)
  173.       ;
  174.       (grdraw P0 P1 -1)
  175.       (initget 1) ; disallow nil zero inputs
  176.       (setq P3 (getpoint P2 "\nVertex: "))
  177.       (grdraw P0 P1 -1)
  178.       ;
  179.       (command "_undo" "1")
  180.       ;
  181.       (setq P1W (trans P1 1 0) P3W (trans P3 1 0))
  182.       (setvar
  183.          "blipmode" 0
  184.       )
  185.       (command
  186.          "_ucs" "3p" P2 P1
  187.          (polar P2 (+ ANG (* 0.5 pi)) 1)
  188.       )
  189.       (setq P1 (trans P1W 0 1) P3 (trans P3W 0 1))
  190.       (setq
  191.          P3 (mapcar '* P3 '(0 1))
  192.       )
  193.       (setq POINTS (PARAB P3 P1))
  194.       (setvar "osmode" 0)
  195.       (command "_pline")
  196.       (apply 'command POINTS)
  197.       (command "")
  198.       (command "_pedit" (entlast) "f" "")
  199.       (command "_ucs" "p")
  200.    )
  201.  
  202.    ;==========================================================
  203.    ; Body of PARABOLA Command 
  204.    (if (NOTRANS)
  205.       (progn
  206.          (setq OLD-ERROR *error* *error* ERROR)
  207.          (PUSHVARS
  208.             '(("cmdecho" . 0)
  209.                ("plinewid" . 0)
  210.                ("plinegen" . 1)
  211.                ("orthomode")
  212.                ("blipmode")
  213.                ("osmode")
  214.                ("snapmode")
  215.             )
  216.          )
  217.          (command "_undo" "group")
  218.          (PARABOLA)
  219.          (command "_undo" "end")
  220.          (POPVARS)
  221.       )
  222.       (princ)
  223.    )
  224. )
  225. (princ
  226.    "  PARABOLA.LSP (Copyright 1992 by Looking Glass Microproducts) loaded."
  227. )
  228. (princ)
  229.